-----------------------------------------------------------------------------
--
-- Module      :  Data.Unit.Metric
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :  Eduard Sergeev
-- Stability   :  Highly Experimental
-- Portability :
--
-- Generation of custom Units definitions
--
-----------------------------------------------------------------------------

{-# LANGUAGE TemplateHaskell, TypeOperators, TypeFamilies, NoMonomorphismRestriction,
FlexibleInstances, MultiParamTypeClasses, DeriveFunctor, DeriveFoldable, DeriveTraversable,
FlexibleContexts, UndecidableInstances #-}


module Data.Unit.Generator
(

 ToPeano,
 ToList,
 FromList,

 Unit,

 um,

 Show(..),

 measure,
)
where

import Data.Char (toUpper, toLower, ord)
import Language.Haskell.TH
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Quote

import Data.Unit.Types
import Data.Unit.Instances ((:<:)(..)) -- (UMNumber(UMNumber))

import Text.Parsec
import Control.Applicative ((<*),(*>), pure)
import Data.Foldable
--import Data.Traversable
import Prelude hiding (concat, foldr, concatMap)
import Data.Either
import Control.Monad.State



toPeano 0 = [t| Zero |]
toPeano n = conT ''Succ `appT` toPeano (n-1)


toDataName (c:cs) = toUpper c : cs 

toVarName (c:cs) = toLower c : cs 

uData dName =
  let uName = mkName dName
  in dataD (return []) uName [] [] []
    

--instance cName S where fName _ = "s" 
uInst cName fName sName tag = instanceD (return []) (appT (conT $ mkName cName) (conT $ mkName sName)) [fs]
    where fs = funD (mkName fName) [clause [wildP] (normalB tag) []]


--type instance ToPeano S = Three
uTPeanoInst sName n = tySynInstD (mkName "ToPeano") [conT $ mkName sName] (toPeano n)

--type instance ToList S = U :*: S
--uToListInst sName = tySynInstD (mkName "ToList") [uName]  [t|U :*: $(uName)|]
--    where uName = conT $ mkName sName

--instance (r ~ U :*: S) => ToList S r
uToListInst2 sName = [d|instance ($r ~ (U :*: $uName)) => ToList $uName $r|] >>= return . head
    where
      uName = conT $ mkName sName
      r = varT $ mkName "r"


--type instance FromList (U :*: S) = S
uFromListInst1 sName = tySynInstD (mkName "FromList") [[t|U :*: $(uName)|]] uName
    where uName = conT $ mkName sName

--type instance FromList ((a :*: b) :*: S) = (FromList (a :*: b)) :*: S
uFromListInst2 sName = tySynInstD (mkName "FromList") [[t|($a :*: $b) :*: $uName|]] [t|(FromList ($a :*: $b)) :*: $uName|]
    where
      a = varT $ mkName "a"
      b = varT $ mkName "b"
      uName = conT $ mkName sName

uOneVar name conv = valD vName (normalB [| $fapp 1|]) [] -- = UMNumber 1 :: $(dName) |]
    where
      vName = varP $ mkName (toVarName name)
      fapp = varE (mkName conv)

--type Unit a n = UMNumber a n
type Unit u n = n :<: u

uConv name fName = do
    let fn = mkName fName
        nn = varT $ mkName "n"
        t = conT (mkName name) 
--    f <- funD fn [clause [] (normalB [| UMNumber |]) []]
    f <- funD fn [clause [] (normalB [| Un |]) []]
--    s <- sigD fn [t| (Fractional n) => n -> Unit $(t) n|]
    s <- sigD fn (forallT [PlainTV (mkName "n")] (cxt [classP (mkName "Fractional") [nn]]) ([t|$(nn) -> Unit $(t) $(nn)|]))
    return (s,f)



um :: String -> String -> String -> Q [Dec]
um name fName ns = do
  let n = read ns
      sName = toDataName name
      dName = sName
  d <- uData dName
  si <- uInst "Show" "show" sName [|name|]
  p <- uTPeanoInst sName n
  l <- uToListInst2 sName
  fl1 <- uFromListInst1 sName
  fl2 <- uFromListInst2 sName
--  nu  <- uNormalizeInst sName
--  du  <- uDenormalizeInst sName
  (sf,f) <- uConv sName fName 
  uv <- uOneVar name fName
  return [d,si,p,l,fl1,fl2,sf,f,uv]


data Ex a = Arg a | Op a (Ex a) (Ex a) deriving (Show) --, Functor, Foldable, Traversable)

-- Parser for types
ty = many1 letter >>= return . Arg
op = spaces *> (oneOf "*/" >>= return . pure) <* spaces
ex = arg `chainl1` (op >>= return . Op)
arg = between (char '(') (char ')') ex <|> ty


--tick = modify $ \n -> n+1

conv (Arg a) = return (a , "")

conv (Op o l r) = do
  n <- get
  modify $ \n -> n+1
  (hl,el) <- conv l
  (hr,er) <- conv r
  let r = "r" ++ show n
  return (r , co o hl hr r ++ el ++ er)
    where
      co "*" l r n = "Multiply " ++ l ++ " " ++ r ++ " " ++ n ++ " "
      co "/" l r n = "Divide " ++ l ++ " " ++ r ++ " " ++ n ++ " "


toQ t = 
    let (r,(_,cs,rs)) = runState (toq' t) (1,[],[])
        rs' = map plainTV rs
    in forallT rs' (cxt cs) r

toq' (Arg a) = return (conT $ mkName a)
toq' (Op o l r) = do
        hl <- toq' l
        hr <- toq' r
        (n,ts,rs) <- get
        let r = mkName ("r" ++ show n)
            vr = varT r
        modify $ \(n,ts,rs) -> (n+1 , (co o hl hr vr : ts) , (r : rs))
        return vr
            where
              co "*" l r n = classP (mkName "Multiply") [l,r,n]
              co "/" l r n = classP (mkName "Divide") [l,r,n]


-- m
-- m*s
-- (m*s)
-- (m*s)*s
-- (m*s)/(m*s)
-- ((m*s)/(m*s))

data A
data B
data C

tt = [t|(Divide A B r, Multiply r C r1) => r1|]

inp = either (error "") id $ parse ex "" "M*(M/(S*G))"

typeQuoter = toQ . either (error "") id . parse ex ""

measure  :: QuasiQuoter
measure = QuasiQuoter { quoteType = typeQuoter }